home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / Demos / demo_circsq < prev    next >
Encoding:
Text File  |  1991-12-30  |  1.6 KB  |  82 lines
  1. \ "Circle Square"
  2. \ Generate color patterns by plotting bit fields from
  3. \ polynomial functions of x and y.
  4. \
  5. \ The patterns can be changed by using new functions.
  6. \ Write a word with the following stack diagram
  7. \     ( x y -- f[x,y] )
  8. \ and plug it in to CS-FUNC using IS.
  9. \     ' myword IS CS-FUNC
  10. \
  11. \ Change the zoom factor by adjusting CS-SHIFT .
  12. \
  13. \ Author: Phil Burk
  14. \ Copyright 1986  Delta Research
  15.  
  16. include? gr.init ju:amiga_graph
  17. include? ev.getclass ju:amiga_events
  18.  
  19. ANEW TASK-DEMO_CIRCSQ
  20.  
  21. : GR.POINT ( x y -- , set point )
  22.     gr-currport @ -rot
  23.     call graphics_lib writepixel drop
  24. ;
  25.  
  26. : SQUARE ( X -- X**2 )
  27.     dup *
  28. ;
  29.  
  30. VARIABLE CS-SHIFT   ( effective 'zoom' factor )
  31. -8 CS-SHIFT !
  32.  
  33. defer CS-FUNC   ( vectored function to calculate polynomial )
  34. : SUM.SQUARES  ( i j -- i**2+j**2 )
  35.     square swap square +
  36. ;
  37.  
  38. : DIFF.SQUARES ( i j -- j**2-i**2 )
  39.     square swap square -
  40. ;
  41.  
  42. : CS.FUNC1  ( i j -- [i-1]*i*j )
  43.     over 1- * *   ( works well with cs-shift = -12 )
  44. ;
  45.  
  46. ' sum.squares is cs-func
  47.  
  48. : CIRCSQ.DRAW  ( xmax ymax -- )
  49.     0 DO ( next row )
  50.         dup 0 DO ( next point )
  51.             i j cs-func
  52.             cs-shift @  ashift
  53.             3 AND  gr.color!
  54.             i j gr.point
  55.         LOOP
  56.         ?closebox IF leave THEN
  57.     LOOP drop
  58. ;
  59.  
  60. : CIRCSQ.INIT   ( -- )
  61.     cr ." CIRCSQ - Hit CLOSE BOX to interrupt!" cr
  62.     gr.init            ( Initialize graphics system. )
  63.     gr.opentest        ( Open test window. )
  64. ;
  65.  
  66. VARIABLE CS-XMAX
  67. VARIABLE CS-YMAX
  68.  
  69. 512 CS-XMAX !
  70. 150 CS-YMAX !
  71.  
  72. : CIRCSQ ( -- )
  73.     circsq.init
  74.     cs-xmax @ cs-ymax @ circsq.draw
  75.     ." Hit key to continue." cr
  76.     key drop  ( pause at end to view )
  77.     gr.closecurw
  78.     gr.term
  79. ;
  80.  
  81. cr ." Enter:    CIRCSQ   to see pattern.  Please read file." cr
  82.